home *** CD-ROM | disk | FTP | other *** search
/ Input 64 / Input_64_86-06_1986_Verlag_Heinz_Weise_de.d64 / experte .lsp < prev    next >
Text File  |  2023-02-26  |  9KB  |  271 lines
  1. (do expr (lambda nil (prog (in 
  2. rulesused rule) loop (msg ":_ ") (
  3. setq in (readl)) (cond ((member (car 
  4. in) (quote (ok ende fertig))) (return 
  5. t)) ((eq (last in) (quote :)) (msg 
  6. ":+ ") (setq in (append in (readl)))))
  7.  (eval (to-do in)) (go loop))))
  8. (remember expr (lambda (new) (cond ((
  9. member new facts) nil) (t (setq facts 
  10. (cons new facts)) new))))
  11. (recall expr (lambda (fact) (cond ((
  12. member fact facts) fact))))
  13. (testif expr (lambda (rule) (prog (
  14. ifs) (setq ifs (car rule)) loop (cond 
  15. ((null ifs) (return t)) ((recall (car 
  16. ifs))) (t (return nil))) (setq ifs (
  17. cdr ifs)) (go loop))))
  18. (usethen expr (lambda (rule) (prog (
  19. thens success) (setq thens (cadr rule)
  20. ) loop (cond ((null thens) (return 
  21. success)) ((remember (car thens)) (
  22. setq success t) (print-rule rule) (
  23. msg t "deduziert " t "--> ") (princ (
  24. car thens)) (terpri))) (setq thens (
  25. cdr thens)) (go loop))))
  26. (tryrule expr (lambda (rule) (cond ((
  27. testif rule) (rememberrule rule) (
  28. usethen rule)))))
  29. (stepforward expr (lambda nil (prog (
  30. rulelist) (setq rulelist rules) loop (
  31. cond ((null rulelist) (return nil)) ((
  32. tryrule (car rulelist)) (return t))) (
  33. setq rulelist (cdr rulelist)) (go 
  34. loop))))
  35. (deduce expr (lambda nil (setq 
  36. rulesused nil) (prog (progress) loop (
  37. cond ((stepforward) (setq progress t))
  38.  (t (return progress))) (go loop))))
  39. (rules value nil)
  40. (facts value nil)
  41. (hyps value nil)
  42. (verify expr (lambda (fact) (prog (
  43. relevant1 relevant2) (cond ((recall 
  44. fact) (return t))) (setq relevant1 (
  45. inthen fact rules)) (setq relevant2 
  46. relevant1) (cond ((null relevant1) (
  47. cond ((member fact asked) (return nil)
  48. ) ((ask fact) (remember fact) (return 
  49. t)) (t (setq asked (cons fact asked)) 
  50. (return nil))))) loop1 (cond ((null 
  51. relevant1) (go loop2)) ((tryrule (car 
  52. relevant1)) (return t))) (setq 
  53. relevant1 (cdr relevant1)) (go loop1) 
  54. loop2 (cond ((null relevant2) (go 
  55. exit)) ((tryrule+ (car relevant2)) (
  56. return t))) (setq relevant2 (cdr 
  57. relevant2)) (go loop2) exit (return 
  58. nil))))
  59. (tryrule+ expr (lambda (rule) (cond ((
  60. testif+ rule) (rememberrule rule) (
  61. usethen rule)))))
  62. (testif+ expr (lambda (rule) (prog (
  63. ifs) (setq ifs (car rule)) loop (cond 
  64. ((null ifs) (return t)) ((verify (car 
  65. ifs))) (t (return nil))) (setq ifs (
  66. cdr ifs)) (go loop))))
  67. (inif expr (lambda (fact r) (mapcan (
  68. quote (lambda (x) (cond ((member fact 
  69. (car x)) (list x))))) r)))
  70. (inthen expr (lambda (fact r) (mapcan 
  71. (quote (lambda (x) (cond ((member 
  72. fact (cadr x)) (list x))))) r)))
  73. (diagnose expr (lambda nil (setq 
  74. rulesused nil) (prog (asked pos) (
  75. setq pos hyps) loop (cond ((null pos) 
  76. (msg t 
  77. "keine hypothese kann bewiesen werden"
  78.  t) (return nil)) ((verify (car pos)) 
  79. (msg t "die hypothese :" t "--> ") (
  80. princ (car pos)) (msg t "ist wahr" t) 
  81. (return (car pos)))) (msg t 
  82. "die hypothese :" t "--> ") (princ (
  83. car pos)) (msg t 
  84. "kann nicht bewiesen werden" t) (setq 
  85. pos (cdr pos)) (go loop))))
  86. (data value (rules facts hyps))
  87. (ask expr (lambda (s) (msg t 
  88. "ist dies wahr (j/n/w) :" t) (princ s)
  89.  (setq ch (waitchar)) (msg t ch t) (
  90. cond ((eq ch "j") t) ((eq ch "n") f) (
  91. t (tellwhy) (ask s)))))
  92. (tellwhy expr (lambda nil (msg t 
  93. "ich versuche zu beweisen :" t) (
  94. princ (car pos)) (msg t t 
  95. "ich teste :" t) (print-rule rule)))
  96. (print-facts expr (lambda nil (cond (
  97. facts (prlist facts)) (t (msg 
  98. "es sind keine fakten vorhanden!" t)))
  99. ))
  100. (print-hyps expr (lambda nil (cond (
  101. hyps (prlist hyps)) (t (msg 
  102. "noch wurde keine hypothese aufgestellt!"
  103.  t)))))
  104. (print-rules expr (lambda nil (cond (
  105. rules (mapc (quote print-rule) rules))
  106.  (t (msg "bitte regeln eingeben!" t)))
  107. ))
  108. (print-rule expr (lambda (r) (msg t 
  109. "+++ regel " (car (cddr r)) " +++" t) 
  110. (print-if (car r)) (print-then (cadr 
  111. r))))
  112. (prlist expr (lambda (l) (mapc (quote 
  113. (lambda (x) (princ x) (terpri))) l)))
  114. (print-rule-n expr (lambda (n) (cond (
  115. (setq x (get-rule-n n rules)) (
  116. print-rule x)) (t (msg 
  117. "es gibt noch keine regel " n t)))))
  118. (get-rule-n expr (lambda (n r) (prog 
  119. nil loop (cond ((null r) (return nil))
  120.  ((eq n (car (cddr (car r)))) (return 
  121. (car r)))) (setq r (cdr r)) (go loop))
  122. ))
  123. (print-if expr (lambda (ifs) (princ (
  124. cons (quote wenn) (cons (quote :) (
  125. car ifs)))) (terpri) (mapc (quote (
  126. lambda (x) (princ (append (quote (und 
  127. wenn :)) x)) (terpri))) (cdr ifs))))
  128. (print-then expr (lambda (thens) (
  129. princ (cons (quote dann) (cons (quote 
  130. :) (car thens)))) (terpri) (mapc (
  131. quote (lambda (x) (princ (append (
  132. quote (und dann :)) x)) (terpri))) (
  133. cdr thens))))
  134. (forget-fact fexpr (nlambda l (setq 
  135. facts (remove l facts))))
  136. (forget-hyp fexpr (nlambda l (setq 
  137. hyps (remove l hyps))))
  138. (forget-facts expr (lambda nil (setq 
  139. facts nil)))
  140. (forget-hyps expr (lambda nil (setq 
  141. hyps nil)))
  142. (forget-rules expr (lambda nil (setq 
  143. rules nil) (setq rule nil)))
  144. (forget-rule expr (lambda (n) (setq 
  145. rules (remove (get-rule-n n rules) 
  146. rules))))
  147. (change-rule)
  148. (what? expr (lambda nil (msg 
  149. "was soll ich tun ?" t)))
  150. (how fexpr (nlambda fact (cond ((setq 
  151. x (inthen fact rulesused)) (msg 
  152. "mit den fakten :" t) (mapc (quote (
  153. lambda (y) (prlist (car y)))) x)) ((
  154. member fact facts) (msg 
  155. "das faktum war gegeben" t)) (t (msg 
  156. "das habe ich nicht deduziert" t)))))
  157. (why fexpr (nlambda fact (cond ((
  158. member fact hyps) (msg 
  159. "es war eine der hypothesen" t)) ((
  160. setq x (inif fact rulesused)) (msg 
  161. "es folgt daraus :" t) (mapc (quote (
  162. lambda (y) (prlist (cadr y)))) x)) (t 
  163. (msg "das habe ich nicht benutzt" t)))
  164. ))
  165. (which fexpr (nlambda nil (cond ((
  166. null rulesused) (msg "keine" t)) (t (
  167. msg "die regeln ") (princ (mapcar (
  168. quote last) rulesused)) (terpri)))))
  169. (rememberrule expr (lambda (rule) (
  170. cond ((not (member rule rulesused)) (
  171. setq rulesused (cons rule rulesused)))
  172. )))
  173. (rules-with-if fexpr (nlambda l (mapc 
  174. (quote print-rule) (inif l rules))))
  175. (rules-with-then fexpr (nlambda l (
  176. mapc (quote print-rule) (inthen l 
  177. rules))))
  178. (used-rule expr (lambda (n) (cond ((
  179. setq x (get-rule-n n rulesused)) (msg 
  180. "ja:" t) (print-rule x)) (t (msg 
  181. "nein" t)))))
  182. (add-fact fexpr (nlambda l (cond ((
  183. null facts) (setq facts (list l))) ((
  184. member l facts)) (t (nconc1 facts l)))
  185. ))
  186. (add-hyp fexpr (nlambda l (cond ((
  187. null hyps) (setq hyps (list l))) ((
  188. member l hyps)) (t (nconc1 hyps l)))))
  189. (if fexpr (nlambda l (msg "regel " (
  190. add1 (length rules)) t) (setq rule (
  191. list (list l) nil (add1 (length rules)
  192. ))) (cond (rules (nconc1 rules rule)) 
  193. (t (setq rules (list rule))))))
  194. (andif fexpr (nlambda l (nconc1 (car 
  195. rule) l)))
  196. (then fexpr (nlambda l (setq 
  197. then-fact l) (rplaca (cdr rule) (list 
  198. l))))
  199. (is-hyp expr (lambda nil (cond (
  200. then-fact (apply (quote add-hyp) 
  201. then-fact)))))
  202. (andthen fexpr (nlambda l (setq 
  203. then-fact l) (nconc1 (cadr rule) l)))
  204. (to-do expr (lambda (s) (prog (sent) (
  205. setq sent diareg) loop (cond ((null 
  206. sent) (return (list (quote what?)))) (
  207. (match (caar sent) s) (return (
  208. do-func (cdar sent) s)))) (setq sent (
  209. cdr sent)) (go loop))))
  210. (do-func expr (lambda (func s) (cons (
  211. car func) (cond ((cdr (member (quote 
  212. :) s))) ((in-expr s))))))
  213. (do-lisp fexpr (nlambda (l) (print (
  214. eval l))))
  215. (in-expr expr (lambda (l) (cond ((
  216. atom l) nil) ((or (numberp (car l)) (
  217. consp (car l))) (list (car l))) (t (
  218. in-expr (cdr l))))))
  219. (match expr (lambda (p s) (cond ((
  220. null p) (or (null s) (eq (car s) (
  221. quote :)))) ((eq (car p) (quote *)) (
  222. cond ((or (null s) (eq (car s) (quote 
  223. :))) (null (cdr p))) ((match (cdr p) 
  224. s)) ((match p (cdr s))))) ((null s) 
  225. nil) ((eq (car p) (car s)) (match (
  226. cdr p) (cdr s))) ((and (consp (car p))
  227.  (member (car s) (car p))) (match (
  228. cdr p) (cdr s))))))
  229. (diareg value (((wenn).if) ((und dann)
  230. .andthen) ((dann).then) ((und *).
  231. andif) ((als *).is-hyp) (((drucke 
  232. zeige d) * (regeln r)).print-rules) ((
  233. (drucke zeige d) * (fakten f)).
  234. print-facts) (((drucke zeige d) * (
  235. hypothesen h)).print-hyps) (((drucke 
  236. zeige d) * regel *).print-rule-n) (((
  237. vergiss loesche v) * (fakten f)).
  238. forget-facts) (((vergiss loesche v) * 
  239. (hypothesen h)).forget-hyps) (((
  240. vergiss loesche v) * (regeln r)).
  241. forget-rules) (((vergiss loesche v) * 
  242. faktum).forget-fact) (((vergiss 
  243. loesche v) * (hypothese hyp)).
  244. forget-hyp) (((vergiss loesche v) * 
  245. regel *).forget-rule) ((wie *).how) ((
  246. welche *).which) ((warum *).why) ((* (
  247. faktum lerne merke l m) *).add-fact) (
  248. (* (hypothese hyp) *).add-hyp) ((* 
  249. diagnose *).diagnose) ((* (deduziere 
  250. deduzieren deduktion) *).deduce) ((* (
  251. konklusion k) *).rules-with-then) ((* 
  252. (praemisse p) *).rules-with-if) ((* (
  253. angewendet benutzt a) *).used-rule) ((
  254. * lisp *).do-lisp)))
  255. (expfns value (do remember recall 
  256. testif usethen tryrule stepforward 
  257. deduce rules facts hyps verify 
  258. tryrule+ testif+ inif inthen diagnose 
  259. data ask tellwhy print-facts 
  260. print-hyps print-rules print-rule 
  261. prlist print-rule-n get-rule-n 
  262. print-if print-then forget-fact 
  263. forget-hyp forget-facts forget-hyps 
  264. forget-rules forget-rule change-rule 
  265. what? how why which rememberrule 
  266. rules-with-if rules-with-then 
  267. used-rule add-fact add-hyp if andif 
  268. then is-hyp andthen to-do do-func 
  269. do-lisp in-expr match diareg expfns))
  270. nil
  271.